home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / fefix.com / FEFIX101.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-02-07  |  9.1 KB  |  309 lines
  1. program fefix;
  2. {
  3.              An effort to repair the headers in Borland
  4.              Stroked Font files (filename.CHR) that are
  5.              damaged as a result of a SAVE action by the
  6.              Borland Font Editor FE.EXE, found in the
  7.              BGI Toolkit BGIKIT.ZIP.
  8.  
  9.              Author:  Jay Faubion
  10.              Compuserve 72500,3166
  11.              January 25, 1990
  12.              Compiled with Turbo Pascal 5.5
  13.              Released to the public domain
  14.  
  15.              Syntax:  FEFIX [fontfilename] [FE-]
  16.  
  17.              The fontfilename is the name of the damaged font file.
  18.              The FE- means do NOT execute FE.EXE
  19.  
  20.              FEFIX by itself will execute .\FE.EXE so that you may
  21.              edit a font file, which should be then SAVED.  The
  22.              resulting file has a damaged header (signature).
  23.              Next, FEFIX will prompt you for the file name of the
  24.              damaged fontfile, and repair it for you.
  25.  
  26.              Revised 2/7/90: Although the Borland Font Editor was
  27.              happy with the fixed font files, some Borland programs
  28.              were not, generating an error -13 or -19.  The code
  29.              was changed to write a header identical to an existing
  30.              fontfile header; the one for the V1.1 SANS.CHR file.
  31.              The only changes made to that header are in the filename,
  32.              which will be limited to four characters, and of course
  33.              in the file-specific info such as filesize, etc.
  34.  
  35.              Specifics of the header info are found in the code to
  36.              follow.
  37. }
  38. {$V-}
  39. {$M $4000,0,0 }
  40. {$L+}
  41.  
  42. uses
  43.    DOS,
  44.    CRT;
  45.  
  46. const
  47.    Version = 'Version 1.01';
  48.  
  49. type
  50.    fontfile = file of byte;
  51.  
  52. var
  53.    inputfile, outputfile,backupfile     : fontfile;
  54.    i,j,k,x,y,filelen, gotparms          : longint;
  55.    b1,b2,b3,b4                          : Byte;
  56.    Infile,Outfile,backfile,
  57.    Astr,BStr,CStr                       : string;
  58.    TmpFlg, success                      : boolean;
  59.    PStr                                 : pathstr;
  60.    DStr                                 : dirstr;
  61.    NStr                                 : namestr;
  62.    EStr                                 : extstr;
  63.    Directory                             : searchrec;
  64.  
  65. function UCASE(VAR L2U:string) : String;
  66.    VAR i : INTEGER;
  67.        x : String;
  68.    begin
  69.    x := l2u;
  70.    for i := 1 to length(x) DO x[i]:=upcase(x[i]);
  71.    ucase := x;
  72.    end;
  73.  
  74. procedure Clear24;
  75.    begin
  76.    gotoxy(1,24);clreol;gotoxy(1,24);
  77.    end;
  78.  
  79.    {----- Fix new filename -----}
  80. procedure FixFilenames;
  81.    begin
  82.    PStr := infile;
  83.    Pstr := FExpand(Pstr);
  84.    FSplit(Pstr,Dstr,Nstr,Estr);
  85.    NStr := NStr+'    ';
  86.    b1:=$20;
  87.    for i := 1 to 4 do
  88.       begin
  89.          if Nstr[i] = '.' then TmpFlg := true;
  90.          b2:=ord(nstr[i]);
  91.          if not TmpFlg then write(outputfile,b2)
  92.          else write(outputfile,b1);
  93.       end;
  94.    end;
  95.    {---- Fix file size ----}
  96. procedure FixFileSize;
  97.    begin
  98.    k  := filelen div 256;
  99.    j  := filelen - (k*256);
  100.    b1 := j;
  101.    b2 := k;
  102.    write(outputfile,b1);     {low order}
  103.    write(outputfile,b2);     {high order}
  104.    close(outputfile);
  105.    end;
  106.  
  107.    { ---- Adjust header information --- }
  108. procedure AdjustHeader;
  109.    begin
  110.    Reset(Outputfile);
  111.    TmpFlg := false;
  112.    for i := $0 to $5B do read(outputfile,b1);  { skip to filename }
  113.    FixFilenames;
  114.    for i := 1 to 4 do read(outputfile,b1);  { skip to filesize }
  115.    FixFileSize;
  116.    end;
  117. procedure FontEditor;
  118.    begin
  119.    {$I-}
  120.    assign(inputfile,'FE.EXE');
  121.    reset(inputfile);
  122.    {$I+}
  123.    i := IOResult;
  124.    if i <> 0 then
  125.       begin
  126.       writeln('FE.EXE not in current directory!');
  127.       halt(1);
  128.       end;
  129.    SwapVectors;
  130.    exec('FE.exe','');
  131.    SwapVectors;
  132.    end;
  133.  
  134. function CheckFontName : boolean;
  135.    begin
  136.    {$I-}
  137.    assign(InputFile,Infile);
  138.    reset (InputFile);
  139.    i := IOResult;
  140.    if i=0 then CheckFontName:=true else CheckFontName:=false;
  141.    if i=0 then close (InputFile);
  142.    {$I+}
  143.    end;
  144.  
  145.  
  146. Procedure GetFontName;
  147.    begin
  148.    success := false;
  149.    While not success do
  150.        begin
  151.        clrscr;
  152.        findfirst('*.CHR',$3F,Directory);
  153.        if doserror<>18 then writeln( Directory.Name);
  154.  
  155.        while doserror <> 18 do
  156.           begin
  157.           findnext(Directory);
  158.           if doserror<>18 then Writeln( Directory.name);
  159.           end;
  160.        Clear24;
  161.        writeln('Fontnames should be four characters, plus the .chr extension.');
  162.        write('Enter the name of the fontfile (filename.CHR): ');
  163.        readln(InFile);
  164.        if InFile <'@' then InFile := '@';
  165.        success := CheckFontName;
  166.        if Not Success then
  167.           begin
  168.           if Infile ='@' then InFile:='NONAME!';
  169.           Clear24;
  170.           writeln('Couldn''t open ',Infile,'.');
  171.           halt(1);
  172.           end;
  173.        if Infile = Outfile then
  174.           begin
  175.           Clear24;
  176.           writeln('The Input and Output files must have different names!');
  177.           halt(1);
  178.           end;
  179.        end;
  180.    end;
  181.  
  182.              { ----     Is this a damaged file?     ---- }
  183. procedure CheckforDamage;
  184.       begin
  185.                for i := $0 to $80 do read(InputFile,b1);
  186.                         if b1 = $2B then begin
  187.                              Clear24;
  188.                    writeln('This file appears OK!');
  189.                             halt(1);end;
  190.                   close(inputfile); reset(inputfile);
  191.              { ----     Is this a damaged file?     ---- }
  192.       end;
  193.  
  194. procedure RenewHeader;
  195.    var index,i,j,k : integer;
  196.        t : array[0..8] of string;
  197.        h : array[0..150] of integer;
  198.  
  199.    begin
  200.    (*      00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f   *)
  201.    (*    --------------------------------------------------  *)
  202.    t[1]:=' 80 75  8  8 66 71 73 32 83116114111107101100 32   ';
  203.    t[2]:=' 70111110116 32 86 49 46 49 32 45 32 74117108 32   ';
  204.    t[3]:=' 49 50 44 32 49 57 56 56 13 10 67111112121114105   ';
  205.    t[4]:='103104116 32 40 99 41 32 49 57 56 55 44 49 57 56   ';
  206.    t[5]:=' 56 32 66111114108 97110100 32 73110116101114110   ';
  207.    t[6]:=' 97116105111110 97108 13 10 26128  0 83 65 78 83   ';
  208.    t[7]:='198 52  1  0  1  0  0  0  0  0  0  0  0  0  0  0   ';
  209.    t[8]:='  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0   ';
  210.    (* [1]   P  K      B  G  I     S  t  r  o  k  e  d
  211.       [2]      F  o  n  t  V  1  .  1     -     J  u  l
  212.       [3]   1  2  ,     1  9  8  8 ^M ^J  C  o  p  y  r  i
  213.       [4]   g  h  t     (  c  )     1  9  8  7  ,  1  9  8
  214.       [5]   8     B  o  r  l  a  n  d     I  n  t  e  r  n
  215.       [6]   a  t  i  o  n  a  l ^M ^J ^Z
  216.    *)
  217.  
  218.    index :=0;
  219.    for j := 1 to 8 do
  220.    for i := 0 to 15 do
  221.       begin
  222.       val( copy(T[j],(i*3)+1,3) ,h[index],k);
  223.       inc(index);
  224.       end;
  225.  
  226.    inc(index); h[index] := 0;
  227.    inc(index); h[index] := 0;
  228.  
  229.    filelen:=0;
  230.    for i := $0 to $7F do
  231.       begin
  232.       b1:=h[i];
  233.       write(Outputfile,b1);
  234.       inc(filelen);
  235.       end;
  236.  
  237.    for i := 1 to (128+92) do
  238.       read(Inputfile,b1);
  239.  
  240.    while not eof(Inputfile) do
  241.       begin
  242.       read(Inputfile,b1);
  243.       write(Outputfile,b1);
  244.       inc(filelen);
  245.       j:= filelen mod 100;
  246.    end;
  247.    close(Outputfile);
  248.    Close(Inputfile);
  249.    end;
  250.  
  251. procedure CleanUp;
  252.    begin
  253.    Assign  (Backupfile,  Backfile)   ;    { Create and         }
  254.    Rewrite (BackUpFile)              ;    {   Destroy a        }
  255.    Close   (BackUpFile)              ;    {   Backup           }
  256.    Erase   (Backupfile)              ;    {   File.......      }
  257.    Rename  (InputFile,   Backfile)   ;    { Input to Backup    }
  258.    Rename  (OutPutFile,  Infile)     ;    { Output to Original }
  259.    end;
  260.  
  261. procedure OpenFiles;
  262.    begin
  263.    assign  (Outputfile, Outfile );
  264.    Assign  (Inputfile,  Infile  );
  265.    rewrite (Outputfile          );
  266.    reset   (Inputfile           );
  267.    end;
  268.  
  269. begin
  270.    clrscr;
  271.    InFile   := 'FEFIX.$'  ;
  272.    Outfile  := 'FEFIX.$$' ;
  273.    Backfile := 'FEFIX.$$$';
  274.    TmpFlg := false;
  275.    gotparms := paramcount;
  276.    if gotparms >0  then
  277.       AStr  :=paramstr(1);
  278.       AStr:=ucase(AStr);
  279.       if AStr='FE-' then TmpFlg :=true
  280.       else TmpFlg:=false;
  281.       InFile:=Astr;                      { Get fontfile on command line}
  282.    if gotparms >1 then
  283.       begin
  284.       AStr:=paramstr(2);
  285.       AStr:=ucase(AStr);
  286.       if AStr='FE-' then TmpFlg :=true
  287.       else TmpFlg:=false;
  288.       end;
  289.    (**)
  290.    if not TmpFlg then FontEditor;        { Execute FE.EXE if present.  }
  291.    TmpFlg := CheckFontName;              { Do we have a valid filename?}
  292.    (**)
  293.    if not TmpFlg then GetFontName;       { No, ask user for a filename.}
  294.  
  295.    gotoxy(1,23);clreol;
  296.    write('FEFIX ',version);
  297.    OpenFiles;                            { Open the files to work on   }
  298.    clear24;
  299.    write('Working on ',InFile,'...');
  300.  
  301.    CheckForDamage;                       { Is this a damaged file?     }
  302.    RenewHeader;                          { Write modified dummy header }
  303.    AdjustHeader;                         { Patch header with good info }
  304.    Cleanup;                              { Get all filenames right     }
  305.  
  306.    Clear24;
  307.    writeln ('Fontfile ',Infile,' repaired.');
  308. end.
  309.